Amiga Collections: Taifun/Taifun 099 (1989-05-15)(Ossowski, Stefan)(DE)(PD).zip/Taifun 099 (1989-05-15)(Ossowski, Stefan)(DE)(PD).adf/PCQ/Source/Utilities.p

Text File | 1989-03-31 | 10KB | 453 lines

external;

{
    Utilities.p (of PCQ Pascal)
    Copyright (c) 1989 Patrick Quaid.

    This module handles the various tables and whatever
run-time business the compiler might have.
}

const
{$I "pasconst.i"}

type
{$I "pastype.i"}

var
{$I "pasvar.i"}

    procedure error(s : string);
        forward;
    function streq(s1, s2 : string) : boolean;
        forward;
    function strcmp(s1, s2 : string) : integer;
        forward;
    procedure nextsymbol;
        forward;

function basetype(orgtype : integer): integer;

{
    This routine returns the base type of type.  If this
routine is used consistently, ranges and subtypes will work with
some consistency.
}

begin
    while (idents[orgtype].offset = vsubrange) or
      (idents[orgtype].offset = vsynonym) do
    orgtype := idents[orgtype].vtype;
    basetype := orgtype;
end;

function highertype(typea, typeb : integer): integer;

{
    This routine returns the more complex type of the two
numeric types passed to it.  In other words a 32 bit integer is
'higher' than a 16 bit one.  When real numbers get in the language,
floating point will be the most complex numeric type.
}

begin
    if (typea = inttype) or (typeb = inttype) then
    highertype := inttype;
    if (typea = shorttype) or (typeb = shorttype) then
    highertype := shorttype;
    highertype := typea;
end;

procedure promotetype(var from : integer; other : integer; reg : integer);

{
    This routine extends reg as necessary to make the 'from'
type equivalent to 'other'.  Again, when real numbers are
implemented this will also be responsible for converting the reg to
FFP format.
}

var
    totype : integer;
begin
    from := basetype(from);
    other := basetype(other);
    totype := highertype(from, other);
    if from = totype then
    return;
    if totype = inttype then begin
    if from = shorttype then
        writeln(output, "\text.l\td", reg)
    else if from = bytetype then begin
        writeln(output, "\text.w\td", reg);
        writeln(output, "\text.l\td", reg);
    end;
    from := inttype;
    end else if totype = shorttype then begin
    if from = bytetype then
        writeln(output, "\text.w\td", reg);
    from := shorttype;
    end;
end;

function match(sym : integer): boolean;

{
    If the current symbol is sym, return true and get the
next one.
}

begin
    if currsym = sym then begin
    nextsymbol;
    match := true;
    end else
    match := false;
end;

{
    The following routines just print out common error messages
and make some common tests.
}

procedure mismatch;
begin
    error("Mismatched types");
end;

procedure neednumber;
begin
    error("Need a numeric type");
end;

procedure noleftparent;
begin
    error("No left parenthesis");
end;

procedure norightparent;
begin
    error("No right parenthesis");
end;

procedure needleftparent;
begin
    if not match(leftparent1) then
    noleftparent;
end;

procedure needrightparent;
begin
    if not match(rightparent1) then
    norightparent;
end;

procedure enterspell(str : string);

{
    This enters the string into the spelling table.
}

begin
    while str^ <> chr(0) do begin
    spelling[spellptr] := str^;
    str := string(integer(str) + 1);
    spellptr := spellptr + 1;
    end;
    spelling[spellptr] := chr(0);
    spellptr := spellptr + 1;
end;

function enterstandard(stobject, stoffset, sttype, stupper, stlower,
            stsize, stindtype : integer) : integer;

{
    This just adds the appropriate record to the array.  It
gets its name because it was originally used to add standard procs
and funcs, but in fact in can be used for just about anything.
}

begin
    idents[identptr].name := string(integer(adr(spelling)) + spellptr - 1);
    idents[identptr].object  := stobject;
    idents[identptr].offset  := stoffset;
    idents[identptr].vtype   := sttype;
    idents[identptr].upper   := stupper;
    idents[identptr].lower   := stlower;
    idents[identptr].size    := stsize;
    idents[identptr].indtype := stindtype;
    identptr := identptr + 1;
    enterstandard := identptr - 1;
end;

procedure ns;

{
    This routine just tests for a semicolon.
}

begin
    if not match(semicolon1) then begin
    if (currsym <> end1) and (currsym <> else1) and (currsym <> until1) then
        error("missing semicolon");
    end else
    while match(semicolon1) do;
end;

function typecmp(typea, typeb : integer) : boolean;

{
    This routine just compares two types to see if they're
equivalent.  Subranges of the same type are considered equivalent.
Note that 'badtype' is actually a universal type used when there
are errors, in order to avoid streams of errors.
}

var
    t1ptr,
    t2ptr  : integer;
begin
    typea := basetype(typea);
    typeb := basetype(typeb);

    if typea = typeb then
    typecmp := true;
    if (typea = badtype) or (typeb = badtype) then
    typecmp := true;
    if idents[typea].offset <> idents[typeb].offset then
    typecmp := false;
    if idents[typea].size <> idents[typeb].size then
    typecmp := false;
    if idents[typea].offset = varray then begin
    if (idents[typea].upper - idents[typea].lower) <>
       (idents[typeb].upper - idents[typeb].lower) then
        typecmp := false;
    typecmp := typecmp(idents[typea].vtype, idents[typeb].vtype);
    end;
    if idents[typea].offset = vpointer then
    typecmp := typecmp(idents[typea].vtype, idents[typeb].vtype);
    if idents[typea].offset = vfile then
    typecmp := typecmp(idents[typea].vtype, idents[typeb].vtype);
    if idents[typea].offset = vrecord then begin
    t1ptr := idents[typea].indtype;
    t2ptr := idents[typeb].indtype;
    while (t1ptr <> 0) and (t2ptr <> 0) do begin
        if not typecmp(idents[t1ptr].vtype, idents[t2ptr].vtype) then
        typecmp := false;
        t1ptr := idents[t1ptr].indtype;
        t2ptr := idents[t2ptr].indtype;
    end;
    typecmp := t1ptr = t2ptr;
    end;
    if (idents[typea].offset = vordinal) and
    (idents[typea].indtype <> 0) then begin
    t1ptr := idents[typea].indtype;
    t2ptr := idents[typeb].indtype;
    while (t1ptr <> 0) and (t2ptr <> 0) do begin
        if not streq(idents[t1ptr].name, idents[t2ptr].name) then
        typecmp := false;
        t1ptr := idents[t1ptr].indtype;
        t2ptr := idents[t2ptr].indtype;
    end;
    typecmp := t1ptr = t2ptr;
    end;
    typecmp := false;
end;

function numbertype(testtype : integer) : boolean;

{
    Return true if this is a numeric type.
}

begin
    testtype := basetype(testtype);
    if testtype = inttype then
    numbertype := true
    else if testtype = shorttype then
    numbertype := true
    else if testtype = bytetype then
    numbertype := true;
    numbertype := false;
end;

function typecheck(typea, typeb : integer) : boolean;

{
    This is similar to typecmp, but considers numeric types
equivalent.
}

begin
    if (idents[typea].object = obtype) and
    (idents[typeb].object = obtype) then begin
    typea := basetype(typea);
    typeb := basetype(typeb);
    if typea = typeb then
        typecheck := true;
    if numbertype(typea) and numbertype(typeb) then
        typecheck := true;
    typecheck := typecmp(typea, typeb);
   end else
    typecheck := false;
end;

function addtype(typoff, typtype, typup, typlow,
            typsize, typind : integer) : integer;

{
    Adds a type to the id array.
}

var
    index    : integer;
    found    : boolean;
begin
    idents[identptr].name    := string(adr(spelling));
    idents[identptr].object  := obtype;
    idents[identptr].offset  := typoff;
    idents[identptr].vtype   := typtype;
    idents[identptr].upper   := typup;
    idents[identptr].lower   := typlow;
    idents[identptr].size    := typsize;
    idents[identptr].indtype := typind;

    identptr := identptr + 1;
    addtype := identptr - 1;
end;

function findid(idname : string): integer;

{
    This finds the index whose 'name' field is the same as
idname, or zero if it doesn't find it.  Note that this searches
backwards, in order to properly do scopes.  It will run into the
most local identifiers first.
    I once thought about implementing case sensitivity through
a compiler directive.  It would have been fairly simple, actually:
just use separate routines in place of streq and strcmp in the
following routines.  These new routines should be case sensitive,
of course.
}

var
    index    : integer;
begin
    index := identptr - 1;
    while index > 0 do begin
    if streq(idname, idents[index].name) then
        findid := index;
    index := index - 1;
    end;
    findid := 0;
end;

function checkid(idname : string; startspot : integer): integer;

{
    This is like the above, but only checks as far back as
startspot in order to implement scopes.  This is used to make sure
there are no identifiers with the same name under the same scope.
}

var
    index    : integer;
begin
    index := startspot;
    while index < identptr do begin
    if idents[index].object <> field then
        if streq(idname, idents[index].name) then
        checkid := index;
    index := index + 1;
    end;
    checkid := 0;
end;

function findfield(idname : string; startspot : integer) : integer;

{
    This just finds the appropriate field, given the index of
the record type.
}

var
    index    : integer;
begin
    index := idents[startspot].indtype;
    while index <> 0 do begin
    if streq(idname, idents[index].name) then
        findfield := index;
    index := idents[index].indtype;
    end;
    findfield := 0;
end;

function searchreserved() : integer;

{
    This just does a binary chop search of the list of reserved
words.
}

var
    top        : integer;
    middle    : integer;
    bottom    : integer;
    compare    : integer;
begin
    bottom := 1;
    top := lastreserved;
    while bottom <= top do begin
    middle := (bottom + top) div 2;
    compare := strcmp(reserved[middle], symtext);
    if compare = 0 then
        searchreserved := middle
    else if compare < 0 then
        bottom := middle + 1
    else
        top := middle - 1;
    end;
    searchreserved := 0;
end;

function isvariable(index : integer) : boolean;

{
    Returns true if index is a variable.
}

var
    what    : integer;
begin
    what := idents[index].object;
    if what = local then
    isvariable := true
    else if what = refarg then
    isvariable := true
    else if what = valarg then
    isvariable := true
    else if what = global then
    isvariable := true
    else
    isvariable := false;
end;

function suffix(size : integer): char;

{
    Returns the proper assembly language suffix for the various
operations.
}

begin
    if size = 1 then
    suffix := 'b'
    else if size = 2 then
    suffix := 'w'
    else if size = 4 then
    suffix := 'l'
    else {must be a bug!}
    suffix := '!';
end;